home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / w3-toolbar.el.z / w3-toolbar.el
Encoding:
Text File  |  1998-05-21  |  12.7 KB  |  345 lines
  1. ;;; w3-toolbar.el --- Toolbar functions for emacs-w3
  2. ;; Author: wmperry
  3. ;; Created: 1998/01/20 14:33:11
  4. ;; Version: 1.14
  5. ;; Keywords: mouse, toolbar
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1995, 1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is part of GNU Emacs.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. ;;; Toolbar specific function for XEmacs 19.12+
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. (condition-case ()
  33.     (progn
  34.       (require 'xpm-button)
  35.       (require 'xbm-button))
  36.   (error nil))
  37.  
  38. (defvar w3-toolbar-icon-directory nil "Where the toolbar icons for w3 are.")
  39. (defvar w3-toolbar-back-icon nil "Toolbar icon for back")
  40. (defvar w3-toolbar-forw-icon nil "Toolbar icon for forward")
  41. (defvar w3-toolbar-home-icon nil "Toolbar icon for home")
  42. (defvar w3-toolbar-reld-icon nil "Toolbar icon for reload")
  43. (defvar w3-toolbar-imag-icon nil "Toolbar icon for images")
  44. (defvar w3-toolbar-open-icon nil "Toolbar icon for open url")
  45. (defvar w3-toolbar-print-icon nil "Toolbar icon for printing")
  46. (defvar w3-toolbar-find-icon nil "Toolbar icon for find")
  47. (defvar w3-toolbar-stop-icon nil "Toolbar icon for stop")
  48. (defvar w3-toolbar-help-icon nil "Toolbar icon for help")
  49. (defvar w3-toolbar-hotl-icon nil "Toolbar icon for hotlist")
  50.  
  51. (defvar w3-link-toolbar-orientation 'bottom
  52.   "*Where to put the document specific toolbar.  Must be one of these symbols:
  53.  
  54. default -- place at location specified by `default-toolbar-position'
  55. top     -- place along the top of the frame
  56. bottom  -- place along the bottom of the frame
  57. right   -- place along the right edge of the frame
  58. left    -- place along the left edge of the frame
  59. none    -- no toolbar")
  60.  
  61. (defvar w3-toolbar-orientation 'default
  62.   "*Where to put the w3 toolbar.  Must be one of these symbols:
  63.  
  64. default -- place at location specified by `default-toolbar-position'
  65. top     -- place along the top of the frame
  66. bottom  -- place along the bottom of the frame
  67. right   -- place along the right edge of the frame
  68. left    -- place along the left edge of the frame
  69. none    -- no toolbar")
  70.  
  71. (defvar w3-toolbar-type 'both
  72.   "*What the toolbar looks like.  Must be one of these symbols:
  73.  
  74. pictures -- Show icons (without captions if in XEmacs 19.13)
  75. both     -- Show icons (with captions if in XEmacs 19.13)
  76. text     -- Show only text buttons
  77.  
  78. Only has any meaning in XEmacs 19.12 when w3-toolbar-orientation is
  79. not `none'.")
  80.  
  81. (defvar w3-toolbar
  82.   '([w3-toolbar-back-icon w3-history-backward (car (w3-history-find-url-internal (url-view-url t))) "Back in history"]
  83.     [w3-toolbar-forw-icon w3-history-forward (cdr (w3-history-find-url-internal (url-view-url t))) "Forward in history"]
  84.     [w3-toolbar-home-icon w3 t "Go home"]
  85.     [:style 2d :size 5]
  86.     [w3-toolbar-reld-icon w3-reload-document t "Reload document"]
  87.     [w3-toolbar-hotl-icon w3-show-hotlist t "View hotlist"]
  88.     [w3-toolbar-imag-icon w3-load-delayed-images w3-delayed-images
  89.               "Load images"]
  90.     [toolbar-file-icon w3-fetch t "Fetch a URL"]
  91.     [toolbar-printer-icon w3-mouse-print-this-url t "Print document"]
  92.     [w3-toolbar-find-icon w3-search-forward t "Search"]
  93.     ;;[w3-toolbar-stop-icon keyboard-quit t "Stop transaction"]
  94.     nil
  95.     [w3-toolbar-help-icon w3-show-info-node t "Help"])
  96.   "The toolbar for w3")
  97.  
  98. (defun w3-toolbar-make-captioned-buttons ()
  99.   (mapcar
  100.    (function
  101.     (lambda (x)
  102.       (let* ((ext (if (featurep 'xpm) ".xpm" ".xbm"))
  103.          (base w3-toolbar-icon-directory)
  104.          (up (expand-file-name (concat x "-up" ext) base))
  105.          (dn (expand-file-name (concat x "-dn" ext) base))
  106.          (no (expand-file-name (concat x "-no" ext) base))
  107.          (cap-up (expand-file-name (concat x "-cap-up" ext) base))
  108.          (cap-dn (expand-file-name (concat x "-cap-dn" ext) base))
  109.          (cap-no (expand-file-name (concat x "-cap-no" ext) base))
  110.          (var (intern (concat "w3-toolbar-" x "-icon"))))
  111.     (set var
  112.          (toolbar-make-button-list up dn no cap-up cap-dn cap-no)))))
  113.    
  114.    '("back" "help" "find" "forw" "home"  "hotl" "stop" "imag" "reld")))
  115.  
  116. (defun w3-make-text-toolbar-button (text)
  117.   (let ((bgcol (or
  118.         (cdr-safe (assq 'background-toolbar-color (frame-parameters)))
  119.         "#befbbefbbefb")))
  120.     (if (featurep 'xpm)
  121.     (mapcar 'make-glyph (xpm-button-create text 0 "black" bgcol))
  122.       (xbm-button-create text 0))))
  123.  
  124. (defun w3-toolbar-make-text-buttons ()
  125.   (let ((bgcol (or (cdr-safe (assq 'background-toolbar-color
  126.                    (frame-parameters)))
  127.            "#befbbefbbefb")))
  128.     (setq w3-toolbar-back-icon (w3-make-text-toolbar-button "Back")
  129.       w3-toolbar-forw-icon (w3-make-text-toolbar-button "Forward")
  130.       w3-toolbar-home-icon (w3-make-text-toolbar-button "Home")
  131.       w3-toolbar-reld-icon (w3-make-text-toolbar-button "Reload")
  132.       w3-toolbar-hotl-icon (w3-make-text-toolbar-button "Hotlist")
  133.       w3-toolbar-imag-icon (w3-make-text-toolbar-button "Images")
  134.       w3-toolbar-open-icon (w3-make-text-toolbar-button "Open")
  135.       w3-toolbar-print-icon (w3-make-text-toolbar-button "Print")
  136.       w3-toolbar-find-icon (w3-make-text-toolbar-button "Find")
  137.       w3-toolbar-help-icon (w3-make-text-toolbar-button "Help!"))))
  138.  
  139. (defun w3-toolbar-make-picture-buttons ()
  140.   (mapcar
  141.    (function
  142.     (lambda (x)
  143.       (let* ((ext (if (featurep 'xpm) ".xpm" ".xbm"))
  144.          (base w3-toolbar-icon-directory)
  145.          (up (expand-file-name (concat x "-cap-up" ext) base))
  146.          (dn (expand-file-name (concat x "-cap-dn" ext) base))
  147.          (no (expand-file-name (concat x "-cap-no" ext) base))
  148.          (var (intern (concat "w3-toolbar-" x "-icon"))))
  149.     (set var
  150.          (cond
  151.           ((and (file-exists-p up) (file-exists-p dn)
  152.             (file-exists-p no))
  153.            (toolbar-make-button-list up dn no))
  154.           ((file-exists-p up)
  155.            (toolbar-make-button-list up))
  156.           (t nil))))))
  157.    '("back" "help" "find" "forw" "home" "hotl" "imag" "reld")))
  158.  
  159. (defun w3-toolbar-make-buttons ()
  160.   (if (not w3-toolbar-icon-directory)
  161.       (setq w3-toolbar-icon-directory
  162.         (if (fboundp 'locate-data-directory)
  163.         (locate-data-directory "w3")
  164.           (file-name-as-directory
  165.            (expand-file-name "w3" data-directory)))))
  166.   (condition-case nil
  167.       (cond
  168.        ((not (fboundp 'toolbar-make-button-list))
  169.     nil)
  170.        ((or (eq w3-toolbar-type 'text)
  171.         (null w3-toolbar-icon-directory)
  172.         (not (file-directory-p w3-toolbar-icon-directory)))
  173.     (w3-toolbar-make-text-buttons))
  174.        ((boundp 'toolbar-buttons-captioned-p)
  175.     (w3-toolbar-make-captioned-buttons))
  176.        (t
  177.     (w3-toolbar-make-picture-buttons)))
  178.     (error nil)))
  179.  
  180. (defun w3-link-is-defined (rel &optional rev)
  181.   (or
  182.    (cdr-safe (assoc rel (cdr-safe (assq 'rel w3-current-links))))
  183.    (cdr-safe (assoc (or rev rel) (cdr-safe (assq 'rev w3-current-links))))))
  184.  
  185. ;; Need to create w3-toolbar-glos-icon
  186. ;;                w3-toolbar-toc-icon
  187. ;;                w3-toolbar-copy-icon
  188. (defvar w3-link-toolbar
  189.   '([info::toolbar-prev-icon
  190.      (w3-fetch (w3-link-is-defined "previous" "next"))
  191.      (w3-link-is-defined "previous" "next")
  192.      "Back"]
  193.     [info::toolbar-next-icon
  194.      (w3-fetch (w3-link-is-defined "next" "previous"))
  195.      (w3-link-is-defined "next" "previous")
  196.      "Next"]
  197.     [info::toolbar-up-icon
  198.      (w3-fetch (w3-link-is-defined "up" "down"))     
  199.      (w3-link-is-defined "up" "down")
  200.      "Up"]
  201.     [w3-toolbar-home-icon
  202.      (w3-fetch (w3-link-is-defined "home"))
  203.      (w3-link-is-defined "home")
  204.      "Home"]
  205.     [w3-toolbar-toc-icon
  206.      (w3-fetch (w3-link-is-defined "toc"))
  207.      (w3-link-is-defined "toc")
  208.      "Contents"]
  209.     [w3-toolbar-find-icon
  210.      (w3-fetch (w3-link-is-defined "index"))
  211.      (w3-link-is-defined "index")
  212.      "Index"]
  213.     [w3-toolbar-glos-icon
  214.      (w3-fetch (w3-link-is-defined "glossary"))
  215.      (w3-link-is-defined "glossary")
  216.      "Glossary"]
  217.     [w3-toolbar-copy-icon
  218.      (w3-fetch (w3-link-is-defined "copyright"))
  219.      (w3-link-is-defined "copyright")
  220.      "Copyright"]
  221.     [w3-toolbar-hotl-icon
  222.      (w3-fetch (w3-link-is-defined "bookmark"))
  223.      (w3-link-is-defined "bookmark")
  224.      "Bookmarks"]
  225.     nil
  226.     [w3-toolbar-help-icon
  227.      (w3-fetch (w3-link-is-defined "help"))
  228.      (w3-link-is-defined "help")
  229.      "Help"]
  230.     ))
  231.  
  232. (defun w3-toolbar-from-orientation (orientation)
  233.   (cond
  234.    ((eq 'default w3-toolbar-orientation) default-toolbar)
  235.    ((eq 'bottom w3-toolbar-orientation) bottom-toolbar)
  236.    ((eq 'top w3-toolbar-orientation) top-toolbar)
  237.    ((eq 'left w3-toolbar-orientation) left-toolbar)
  238.    ((eq 'right w3-toolbar-orientation) right-toolbar)))
  239.  
  240. (defun w3-toolbar-dimension-from-orientation (orientation)
  241.   (cond
  242.    ((eq 'default w3-toolbar-orientation) nil)
  243.    ((eq 'bottom w3-toolbar-orientation) bottom-toolbar-height)
  244.    ((eq 'top w3-toolbar-orientation) top-toolbar-height)
  245.    ((eq 'left w3-toolbar-orientation) left-toolbar-width)
  246.    ((eq 'right w3-toolbar-orientation) right-toolbar-width)))
  247.  
  248. (defun w3-ensure-toolbar-visible (orientation)
  249.   ;; Make sure a certain toolbar is visible if necessary
  250.   ;; This can modify frame parameters, so watch out.
  251.   (let ((dimension (w3-toolbar-dimension-from-orientation orientation))
  252.     (toolbar   (w3-toolbar-from-orientation orientation))
  253.     (dimensions nil)
  254.     (widths nil)
  255.     (heights nil)
  256.     (needs nil)
  257.     (has nil))
  258.     (if (and dimension toolbar
  259.          (setq toolbar (specifier-instance toolbar)))
  260.     (progn
  261.       (setq dimensions (mapcar
  262.                 (function
  263.                  (lambda (glyph)
  264.                    (and (glyphp glyph)
  265.                     (cons (glyph-width glyph)
  266.                       (glyph-height glyph)))))
  267.                 (mapcar 'car
  268.                     (delq nil
  269.                       (mapcar
  270.                        (function (lambda (x)
  271.                                (and x
  272.                                 (symbol-value
  273.                                  (aref x 0)))))
  274.                        toolbar))))
  275.         widths (sort (mapcar 'car dimensions) '>=)
  276.         heights (sort (mapcar 'cdr dimensions) '>=)
  277.         needs (+ 7 (if (memq orientation '(top bottom))
  278.                   (car heights)
  279.                 (car widths)))
  280.         has (specifier-instance dimension))
  281.       (if (<= has needs)
  282.           (set-specifier dimension (cons (selected-frame) needs)))))))
  283.                  
  284. (defun w3-toolbar-active ()
  285.   (interactive)
  286.   (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
  287.     (if (and toolbar (specifier-instance toolbar))
  288.     t
  289.       nil)))
  290.  
  291. (defun w3-toggle-link-toolbar ()
  292.   (interactive)
  293.   (require 'info)            ; For some toolbar buttons
  294.   (let* ((w3-toolbar-orientation w3-link-toolbar-orientation)
  295.      (toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
  296.     (if toolbar
  297.     (if (w3-toolbar-active)
  298.         (set-specifier toolbar (cons (current-buffer) nil))
  299.       (set-specifier toolbar w3-link-toolbar (current-buffer))))))
  300.  
  301. (defun w3-toggle-toolbar ()
  302.   (interactive)
  303.   (if (eq major-mode 'w3-mode)
  304.       (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
  305.     (cond
  306.      ((w3-toolbar-active)
  307.       (set-specifier toolbar (cons (current-buffer) nil)))
  308.      (toolbar
  309.       (set-specifier toolbar (cons (current-buffer) w3-toolbar)))
  310.      (t
  311.       (setq w3-toolbar-orientation 'default
  312.         toolbar (w3-toolbar-from-orientation w3-toolbar-orientation))
  313.       (and toolbar
  314.            (set-specifier toolbar (cons (current-buffer) w3-toolbar))))))
  315.     (if (not (eq w3-toolbar-orientation 'none))
  316.     (setq w3-toolbar-orientation 'none)
  317.       (setq w3-toolbar-orientation 'default))))
  318.  
  319. (defun w3-show-info-node ()
  320.   (interactive)
  321.   (Info-goto-node "(w3.info)Top"))
  322.  
  323. (defun w3-mouse-print-this-url (&optional e)
  324.   (interactive "e")
  325.   (let ((descr '("Print document as"
  326.          ["PostScript" (w3-print-this-url nil "PostScript") t]
  327.          ["Formatted Text" (w3-print-this-url nil "Formatted Text") t]
  328.          ["HTML Source" (w3-print-this-url nil "HTML Source") t]
  329.          ["LaTeX'd" (w3-print-this-url nil "LaTeX'd") t]
  330.          nil
  331.          ["Cancel" (beep) t])))
  332.     (popup-dialog-box descr)))
  333.  
  334. (defun w3-add-toolbar-to-buffer ()
  335.   (if (or (not (featurep 'toolbar))
  336.       (featurep 'infodock))        ; InfoDock uses different toolbars
  337.       nil
  338.     (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
  339.       (if toolbar
  340.       (set-specifier toolbar (cons (current-buffer) w3-toolbar))))
  341.     (set-specifier toolbar-buttons-captioned-p
  342.            (cons (current-buffer) (eq w3-toolbar-type 'both)))))
  343.  
  344. (provide 'w3-toolbar)
  345.